home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / scsh / defrec.scm < prev    next >
Text File  |  1995-10-13  |  6KB  |  169 lines
  1. ;;; Copyright (c) 1993 by Olin Shivers.
  2.  
  3. ;;; Syntax for defining record types.
  4. ;;; This implementation works with the Scheme48 system --
  5. ;;; or any Scheme that uses Clinger's "explicit renaming"
  6. ;;; macro system.
  7. ;;;
  8. ;;; (define-record name . field&method-specs)
  9. ;;;
  10. ;;; A field-spec is one of the following:
  11. ;;;     field        ; Initialised field
  12. ;;;     (field [default])    ; Defaulted field.
  13. ;;; An initialised field has its initial value passed as an argument to
  14. ;;; the the record maker procedure. A defaulted field takes its value from
  15. ;;; the the DEFAULT expression. If a DEFAULT expression is not given, then
  16. ;;; the defaulted field's initial value is undefined.
  17. ;;; 
  18. ;;; Example:
  19. ;;; (define-record employee
  20. ;;;     name
  21. ;;;     id
  22. ;;;     (salary 10000)
  23. ;;;     (department)    ; Initial value undefined.
  24. ;;;     sex
  25. ;;;     married?)
  26. ;;; 
  27. ;;; Defines the following:
  28. ;;; - A maker procedure:
  29. ;;;   (make-employee "John Smith" 742931 'male #f)
  30. ;;;   MAKE-EMPLOYEE takes one argument for each initialised field.
  31. ;;; 
  32. ;;; - Accessor procedures:
  33. ;;;   (employee:name emp)
  34. ;;;   (employee:id-number emp)
  35. ;;;   (employee:salary emp)
  36. ;;;   (employee:department emp)
  37. ;;;   (employee:sex emp)
  38. ;;;   (employee:married? emp)
  39. ;;; 
  40. ;;; - Setter procedures:
  41. ;;;   (set-employee:name emp)
  42. ;;;   (set-employee:id-number emp)
  43. ;;;   (set-employee:salary emp 20000)
  44. ;;;   (set-employee:department emp "Vaporware")
  45. ;;;   (set-employee:sex emp 'female)
  46. ;;;   (set-employee:married? emp #t)
  47. ;;; 
  48. ;;; - A type predicate:
  49. ;;;   (employee? x)
  50. ;;; 
  51. ;;; - The record type descriptor:
  52. ;;;     type/employee
  53.  
  54. ;;; Method specs are of the form
  55. ;;; ((method self var ...) body ...)
  56. ;;; The only supported method is DISCLOSE, which is used by the S48
  57. ;;; structure printer. E.g.,
  58. ;;;   (define-record ship
  59. ;;;     x
  60. ;;;     y
  61. ;;;     name
  62. ;;;     ((disclose self) (list (ship:name self))))
  63. ;;; will cause (make-ship 10 20 "Valdez") to print as
  64. ;;;   #{ship "Valdez"}
  65.  
  66.  
  67. (define-syntax define-record
  68.   (lambda (form rename compare)
  69.     (receive (field-specs method-specs)
  70.          ;; Partition the field and method specs by form.
  71.          (let lp ((specs (reverse (cddr form)))
  72.               (fspecs '())
  73.               (mspecs '()))
  74.            (if (pair? specs)
  75.            (let ((spec (car specs))
  76.              (specs (cdr specs)))
  77.              (if (and (pair? spec) (pair? (car spec)))
  78.              ;; We only support the DISCLOSE method in S48.
  79.              (if (eq? (caar spec) 'disclose)
  80.                  (lp specs fspecs (cons spec mspecs))
  81.                  (error "Unsupported method in define-record." spec))
  82.              (lp specs (cons spec fspecs) mspecs)))
  83.            (values fspecs mspecs)))
  84.  
  85.       (let* ((name (cadr form))
  86.          (s->s symbol->string)
  87.          (s-conc (lambda args (string->symbol (apply string-append args))))
  88.          (spec-name (lambda (s) (if (pair? s) (car s) s)))
  89.          (filter (lambda (pred lst)
  90.                (let f ((lst lst))
  91.              (if (pair? lst)
  92.                  (let ((tail (f (cdr lst))))
  93.                    (if (pred (car lst)) (cons (car lst) tail) tail))
  94.                  '()))))
  95.          (gensym (let ((j 0))
  96.                (lambda (s) (set! j (+ j 1))
  97.                    (s-conc s (number->string j)))))
  98.  
  99.          (field-name (lambda (field-name)
  100.                (s-conc (s->s name) ":" (s->s field-name))))
  101.          (set-name (lambda (field-name)
  102.              (s-conc "set-" (s->s name) ":" (s->s field-name))))
  103.          (pred-name (s-conc (s->s name) "?"))
  104.          (maker-name (s-conc "make-" (s->s name)))
  105.          (type-name (s-conc "type/" (s->s name)))
  106.  
  107.          (fields (map spec-name field-specs))
  108.          (param-fields (filter symbol? field-specs)) ; Args to maker proc.
  109.          (default-field-specs (filter (lambda (fs) (and (pair? fs)
  110.                                 (pair? (cdr fs))))
  111.                       field-specs))
  112.          (default-exps (map cadr default-field-specs))
  113.          (param-vars (map (lambda (fs) (rename (gensym "field")))
  114.                   param-fields))
  115.  
  116.          (maker (rename 'maker))
  117.          (%make-record-type   (rename 'make-record-type))
  118.          (%record-constructor (rename 'record-constructor))
  119.          (%record-predicate      (rename 'record-predicate))
  120.          (%record-accessor      (rename 'record-accessor))
  121.          (%record-modifier      (rename 'record-modifier))
  122.          (%def-rec-discloser  (rename 'define-record-discloser))
  123.          (%unspecified      (rename 'unspecified))
  124.          (%define          (rename 'define))
  125.          (%let          (rename 'let))
  126.          (%lambda          (rename 'lambda))
  127.          (%begin          (rename 'begin)))
  128.  
  129.     `(,%begin
  130.       (,%define ,type-name
  131.         (,%make-record-type ,(s->s name) ',fields))
  132.  
  133.       ;; Maker proc (MAKE-EMPLOYEE name id-number sex married?)
  134.       (,%define ,maker-name
  135.         ,(if (null? default-field-specs)
  136.          ;; Gratuitous optimisation:
  137.          `(,%record-constructor ,type-name ',param-fields)
  138.           
  139.          ;; Full-blown form.
  140.          `(,%let ((,maker (,%record-constructor
  141.                    ,type-name
  142.                    ',(append param-fields
  143.                          (map spec-name
  144.                           default-field-specs)))))
  145.              (,%lambda ,param-vars
  146.                    (,maker ,@param-vars ,@default-exps)))))
  147.  
  148.       ;; Type predicate (EMPLOYEE? x)
  149.       (,%define ,pred-name (,%record-predicate ,type-name))
  150.        
  151.       ;; Accessors (EMPLOYEE:NAME emp), ...
  152.       ,@(map (lambda (spec)
  153.            `(,%define ,(field-name (spec-name spec))
  154.               (,%record-accessor ,type-name ',(spec-name spec))))
  155.          field-specs)
  156.  
  157.       ;; Setters (SET-EMPLOYEE:NAME emp name), ...
  158.       ,@(map (lambda (spec)
  159.            `(,%define ,(set-name (spec-name spec))
  160.               (,%record-modifier ,type-name ',(spec-name spec))))
  161.          field-specs)
  162.  
  163.       ;; Methods (we only handle DISCLOSE methods).
  164.       ,@(map (lambda (m)
  165.            `(,%def-rec-discloser ,type-name
  166.               (,%lambda ,(cdar m) . ,(cdr m))))
  167.          method-specs)
  168.       )))))
  169.